      SUBROUTINE OPT(A0,NP,FU0,METHOD,ITERL1,MX1,IER1,ACC1,FUNC,ALABEL)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*8 ALABEL(NP)
      DIMENSION A0(NP)
      COMMON/BSTACK/A(150000)
      COMMON/BOPT1/NPARS,JH,JFP,JFP1,JSP,JSP2,JA1,JS,JBHHH
      COMMON/BOPT2/ACC,R ,PM1,IVAL,ITERL,ITERC,MX,IER
      COMMON/BOPT3/JSMP,JF,JSPD
      COMMON/BOPT9/JX1,JD0,JD1,JTEMV,JG0,JG1,JV,JP,JQ,JSS,JXT
      COMMON/BPROB/IPROB,JPROB
      COMMON/BPROB1/WP,SSR,ER2,WSSR,SCC,FAD,JFLG,IFLG,KFLG,LFLG
      COMMON/BPROB2/KPROB
      COMMON/BSTAK/NQ,NTOP
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      COMMON/BLNSR/STEP1,STPACC,NLNSR
      COMMON/BSTOP/NVAR1,ISTOP(3)
      COMMON/BTRAT/ITRFLG
      COMMON/BVAL/VAL
      COMMON/BTOB1/ITOB
      EXTERNAL FUNC
      EXTERNAL METHOD
      EXTERNAL BDUMMY
CVMS  *************************
      IF(.false.)CALL BDUMMY
C ******DUMMY CALL TO LOAD BLOCK DATA FOR PU ONLY**********
C
C     TO BRING THE DATA BLOCK INFORMATION IN FILE BDUMMY INTO THE GQOPT
C     LINKING, THE DATA BLOCK IN FILE BDUMMY WAS GIVEN THE NAME BDUMMY
C
c ****this turned off
C     HERE AND IN SUBROUTINE DERIV INITIALIZATIONS ARE PERFORMED FOR
C     THE VARIABLES USED BY THE RANDOM NUMBER GENERATOR GGNML (FROM
C     THE IMSL PACKAGE) FOUND IN SUBROUTINE RXX.
c     COMMON /VMSRAN/ VMSEED,VMSNR,VMSR
c     REAL*8  VMSEED
c     INTEGER VMSNR
c     REAL    VMSR(1)
c     IF (VMSNR .EQ. 1) GOTO 10
c     VMSEED= INT(SECNDS(0.)*1000)
c     IF (INT(VMSEED/2.) .EQ. VMSEED/2.) VMSEED=INT(VMSEED+1)
c     VMSNR= 1
   10 CONTINUE
C
C     THE FOLLOWING STATEMENT REDIRECTS THE 'UNIT NFILE' OUTPUT FROM
C     THE DEFAULT (FILE FOR***.DAT) TO THE TERMINAL, AS WAS INTENDED.
CVMS  *************************
      IF(NP.LT.1)GOTO 6
      IF (ISTOP(1)*ISTOP(2)*ISTOP(3).NE.0) GO TO 7
      NPARS=NP
C      SET TO ZERO TO ENABLE OPTOUT TO DETECT USE
      JH=0
      JFP=0
      JSP=0
      JSMP=0
      JSP1 = 0
      JS=0
      JSPD=0
      JX1=0
      JD0=0
      JG0=0
      JSS=0
      ITERL=ITERL1
      MX=1
      IF(MX1.GT.1)MX=2
      PM1=DFLOAT(3-2*MX)
      ITERC=0
      IVAL=0
      IER=0
      ACC=ACC1
      ST=STPACC
      IF(STPACC.LE.0.0)STPACC=ACC
      NV=NVAR1
      IF(NVAR1.LE.0)NVAR1=NP
      NVAR1=MIN0(NVAR1,NP)
      LASTOP=NTOP
      IF(ITOB*IPROB.EQ.0) GOTO 3
      IER=-38
      IF(IPT.GT.0) WRITE (NFILE,920)
      IF(JPT.GT.0) WRITE (MFILE,921)
      RETURN
3     CALL METHOD(A0,NP,FU0,FUNC)
      VAL=FU0
      NVAR1=NV
      STPACC=ST
      IER1=IER
      IF(IPT.EQ.0.AND.JPT.EQ.0)GO TO 800
      IF(IER.EQ.-1.AND.IPT.NE.0)WRITE(NFILE,912)
      IF(IER.EQ.-1.AND.JPT.NE.0)WRITE(MFILE,912)
      IF(IER.EQ.-2.AND.IPT.NE.0)WRITE(NFILE,915)
      IF(IER.EQ.-2.AND.JPT.NE.0)WRITE(MFILE,915)
      IF(IER.EQ.-4.AND.IPT.NE.0)WRITE(NFILE,928)
      IF(IER.EQ.-4.AND.JPT.NE.0)WRITE(MFILE,928)
      IF(IER.EQ.-5.AND.IPT.NE.0)WRITE(NFILE,925)
      IF(IER.EQ.-5.AND.JPT.NE.0)WRITE(MFILE,925)
      IF(IER.EQ.-15.AND.IPT.NE.0) WRITE (NFILE,934)
      IF(IER.EQ.-15.AND.JPT.NE.0) WRITE (MFILE,934)
      IF(IER.EQ.-16.AND.IPT.NE.0) WRITE (NFILE,924)
      IF(IER.EQ.-16.AND.JPT.NE.0) WRITE (MFILE,924)
      IF(IER.EQ.-9.AND.IPT.NE.0) WRITE (NFILE,919)
      IF(IER.EQ.-9.AND.JPT.NE.0) WRITE (MFILE,919)
      IF(IER.EQ.-24.AND.IPT.NE.0) WRITE (NFILE,945)
      IF(IER.EQ.-24.AND.JPT.NE.0) WRITE (MFILE,945)
      IF(IER.EQ.-42.AND.IPT.NE.0) WRITE (NFILE,938)
      IF(IER.EQ.-42.AND.JPT.NE.0) WRITE (MFILE,938)
      IF(IER.EQ.-39.AND.IPT.NE.0) WRITE (NFILE,935)
      IF(IER.EQ.-39.AND.JPT.NE.0) WRITE (MFILE,935)
      IF(IER.EQ.-40.AND.IPT.NE.0) WRITE (NFILE,936)
      IF(IER.EQ.-40.AND.JPT.NE.0) WRITE (MFILE,936)
      IF(IER.EQ.-41.AND.IPT.NE.0) WRITE (NFILE,937)
      IF(IER.EQ.-41.AND.JPT.NE.0) WRITE (MFILE,937)
      IF (IER.EQ.-14.AND.IPT.NE.0) WRITE (NFILE,929)
      IF (IER.EQ.-14.AND.JPT.NE.0) WRITE (MFILE,929)
      IF (IER.LT.0.AND.JH+JSP1.NE.0.AND.IPT.NE.0) WRITE (NFILE,933)
      IF (IER.LT.0.AND.JH+JSP1.NE.0.AND.JPT.NE.0) WRITE (MFILE,933)
      IF(IER.EQ.1.AND.IPT.NE.0)WRITE(NFILE,916)
      IF(IER.EQ.1.AND.JPT.NE.0)WRITE(MFILE,916)
      IF(IER.EQ. 2.AND.IPT.NE.0)WRITE(NFILE,917)
      IF(IER.EQ. 2.AND.JPT.NE.0)WRITE(MFILE,917)
      IF(IER.EQ. 3.AND.IPT.NE.0)WRITE(NFILE,918)
      IF(IER.EQ. 3.AND.JPT.NE.0)WRITE(MFILE,918)
      IF(IER.GT.0.AND.IPT.NE.0)WRITE(NFILE,911)
      IF(IER.GT.0.AND.JPT.NE.0)WRITE(MFILE,911)
      IF(IPT.NE.0)WRITE(NFILE,926)IVAL,ITERC,FU0
      IF(JPT.NE.0)WRITE(MFILE,926)IVAL,ITERC,FU0
11    IF(IPT.NE.0) WRITE (NFILE,930) (ALABEL(I),A0(I),I=1,NP)
      IF(JPT.NE.0) WRITE(MFILE,930) (ALABEL(I),A0(I),I=1,NP)
C
C     T-RATIO ROUTINE
C
800   IF (ITRFLG.EQ.0) GO TO 900
      IF (JH.LT.1.AND.JSP1.LT.1.AND.JD0.LT.1) GO TO 802
      IF (NQ.LT.NTOP+NP*NP) GO TO 801
      NP2 = NP*NP
      CALL OPTMOV (1,A(NTOP+1),NP2)
      CALL TRATIO (A(NTOP+1),NP,MX,A0,ALABEL)
900   CONTINUE
C      RELEASE SCRATCH STORAGE
901   NTOP=LASTOP
902   RETURN
 6    IF(IPT.GT.0)WRITE(NFILE,927)NP
      IF(JPT.GT.0)WRITE(MFILE,927)NP
      IER1=-3
      GOTO 902
7     IER1=-13
      IF (IPT.GT.0) WRITE (NFILE,932)
      IF (JPT.GT.0) WRITE (MFILE,932)
      GOTO 902
 911  FORMAT(16H OPTIMUM REACHED)
 912  FORMAT(25H1ITERATION LIMIT EXCEEDED)
 915  FORMAT('1FUNCTION ERROR IN FP OR SP')
 916  FORMAT(47H1ATTEMPTED STEPSIZE IS LESS THAN ACC-RELATIVELY)
 917  FORMAT(34H1NORM OF GRADIENT IS LESS THAN ACC)
 918  FORMAT(43H1FUNCTION VALUE IS ACCURATE TO RELATIVE ACC)
919   FORMAT('1FUNCTION ERROR IN FIRST FUNC CALL')
920   FORMAT('1TOBIT MAY NOT BE SELECTED WITH PROBIT OR LOGIT')
921   FORMAT(' TOBIT MAY NOT BE SELECTED WITH PROBIT OR LOGIT')
924   FORMAT('1SMALL GRADIENT WITHOUT MEETING TERMINATION CRITERIA')
 925  FORMAT(41H1CONTINUAL STRAYING INTO FORBIDDEN REGION)
 926  FORMAT(22H0FUNCTION EVALUATIONS=,I5/22H ITERATION COUNT     =,I5/
     *22H FUNCTION VALUE      =,1PD18.10/)
 927  FORMAT(19H1ILLEGAL NP VALUE =,I5)
 928  FORMAT(27H1NOT ENOUGH SCRATCH STORAGE)
929   FORMAT ('1INVALID H MATRIX INPUT')
930   FORMAT ('0',10X,'X VECTOR'/(1X,A8,1X,1PD18.10))
931   FORMAT ('0 X VECTOR'/(1X,1PD18.10))
932   FORMAT (' NO STOPPING CRITERION ENABLED FOR GQOPT--NO',
     * ' OPTIMIZATION DONE')
933   FORMAT (' FAILURE OF GQOPT--T-RATIOS OR H MATRIX MAY ',
     * 'BE UNRELIABLE')
934   FORMAT('1NO STOPPING CRITERION ENABLED FOR RNSRCH--NO OPTIMIZATION
     1 DONE')
935   FORMAT(' LINESEARCH FAILURE')
936   FORMAT(' FUNCTION ERROR AFTER ILOOP SHRINKAGES')
937   FORMAT(' PQ,DEN1 OR DEN2 ERROR')
938   FORMAT(' FUNCTION ERROR AFTER RESETTING H-MATRIX')
945   FORMAT(' GRADIENT INACCURATE---DOES NOT POINT UPHILL')
801   WRITE (NFILE,811)
      WRITE(MFILE,811)
811   FORMAT ('0INSUFFICIENT STORAGE FOR T-RATIO.  REQUEST IGNORED.')
      GO TO 900
802   WRITE (NFILE,812)
      WRITE(MFILE,812)
812   FORMAT (' T-RATIO IS VALID ONLY FOR SUCCESSFUL GRADX AND DFP',
     * ' OPTIMIZATIONS.'/'REQUEST IGNORED.')
      GO TO 900
      END
      SUBROUTINE TRATIO (ATEMP,NP,MX,A0,ALABEL)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*8 ALABEL(NP)
      DIMENSION ATEMP(NP,NP),A0(NP)
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      COMMON/BVAL/VAL
      COMMON/BNOBS/NOBSS
      NSIZE=NP*NP
      CALL OPTMOV (1,ATEMP,NSIZE)
      IF (MX.EQ.1) GO TO 1
C
C     MINIMIZATION PROBLEM
C
      IF (NOBSS.EQ.0) GO TO 12
      FACT = 2.D0*VAL/DFLOAT(NOBSS)
      IF(IPT.NE.0) WRITE (NFILE,13)
      IF(JPT.NE.0) WRITE (MFILE,13)
13    FORMAT ('-SUM-OF-SQUARES MINIMIZATION')
      GO TO 2
12    FACT = 1.D0
      IF(IPT.NE.0) WRITE (NFILE,14)
      IF(JPT.NE.0) WRITE (MFILE,14)
14    FORMAT ('-MAXIMUM LIKELIHOOD FUNCTION')
2     DO 3 I=1,NP
      IF (ATEMP(I,I).LE.0.D0) GO TO 90
3     ATEMP(I,I)=A0(I)/DSQRT(FACT*ATEMP(I,I))
      GO TO 4
C
C     MAXIMIZATION PROBLEM
C
1     IF (NOBSS.NE.0) GOTO 98
      IF(IPT.NE.0) WRITE (NFILE,14)
      IF(JPT.NE.0) WRITE (MFILE,14)
      DO 5 I=1,NP
      IF (ATEMP(I,I).GE.0.D0) GO TO 90
5     ATEMP(I,I)=A0(I)/DSQRT(-ATEMP(I,I))
4     IF(IPT.NE.0)WRITE (NFILE,92) (ALABEL(I),ATEMP(I,I),I=1,NP)
      IF(JPT.NE.0)WRITE (MFILE,92) (ALABEL(I),ATEMP(I,I),I=1,NP)
92    FORMAT (' T-RATIOS'//(1X,A8,3X,D16.8))
      RETURN
90    IF (IPT.EQ.0.AND.JPT.EQ.0) RETURN
      IF(IPT.NE.0) WRITE (NFILE,91)
      IF(JPT.NE.0) WRITE (MFILE,91)
91    FORMAT (' ASYMPTOTIC VARIANCES ARE NOT ALL POSITIVE--ERROR',
     * ' IN T-RATIOS')
      RETURN
98    IF(IPT.NE.0) WRITE(NFILE,94)
      IF(JPT.NE.0) WRITE(MFILE,94)
94    FORMAT ('-T-RATIO REQUESTED FOR MAXIMIZATION WITH NOBSS NOT ZERO')
      RETURN
      END
      SUBROUTINE OPTMOV(M,A,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(N)
      COMMON/BSTACK/AINT(150000)
      COMMON/BOPT1/NPARS,JH,JFP,JFP1,JSP,JSP2,JA1,JS,JBHHH
      COMMON/BOPT3/JSMP,JF,JSPD
      COMMON/BOPT9/JX1,JD0,JD1,JTEMV,JG0,JG1,JV,JP,JQ,JSS,JXT
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      COMMON/BNOBS/NOBSS
      COMMON/BVAL/VAL
      IF(M.LE.0.OR.M.GE.8) GOTO 1000
      IF(N.LE.0) GOTO 1000
      IFLG=0
      GOTO(1,2,3,4,5,6,7),M
7     IFLG=1
      IF (NOBSS.EQ.0) GO TO 2000
      FACT=2.D0*VAL/DFLOAT(NOBSS)
 1    J=JH
      IF(J.LE.0)J=JSP1
      IF(J.LE.0) J=JD0
      GOTO 110
 2    J=JSP
      GOTO 110
 3    J=JFP
      IF(JFP.LE.0) J=JG0
      GOTO 110
 4    J=JSMP
      GOTO 110
 5    J=JS
      IF(JS.LE.0) J=JSS
      GOTO 110
 6    J=JSPD
      GOTO 110
 110  IF(J.LT.1)GOTO 2000
      CALL MOVE(AINT(J),A,N)
      IF (IFLG.EQ.0) RETURN
      DO 111 J=1,N
111   A(J)=A(J)*FACT
      RETURN
 1000 IF(IPT.GT.0)WRITE(NFILE,991)M,N
      IF(JPT.GT.0)WRITE(MFILE,991)M,N
 991  FORMAT(35H1ILLEGAL INPUT PARAMETERS TO OPTMOV,I3,2X,I3)
      RETURN
 2000 IF(IPT.GT.0)WRITE(NFILE,992)M
      IF(JPT.GT.0)WRITE(MFILE,992)M
 992  FORMAT(13H1OPTMOV ARRAY, I3, 14H NOT AVAILABLE)
      RETURN
      END
      SUBROUTINE OPTOU0(A0,NP,F,L)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A0(NP)
      COMMON/BPAT/STPSIZ,SHRINK
      COMMON/BNEL/STP1,VAR,KONVGE,NRST
      COMMON/BDFP/STPMIN,FPT
      COMMON/BFIDIF/FDFRAC,FDMIN
      COMMON/BGRDX3/ACTI,ACTW,ZFUL,BETM
      COMMON/BGRDX2/RTM,EIG,RTMULT
      COMMON/BGRDX1/NTRM,NBHHH,LBHHH,KBHHH
      COMMON/BLNSR/STEP1,STPACC,NLNSR
      COMMON/BSTOP/NVAR1,ISTOP(3)
      COMMON/BPROB/IPROB,jprob
      COMMON/BTOB1/ITOB
      COMMON/BSTOP1/JSTOP(2)
      COMMON/BOPT2/ACC,R0,PM1,IVAL,ITERL,ITER ,MX,IER
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      COMMON/BOPT/IX,LT,IFP,ISP,NLOOP,IST,ILOOP
      COMMON/BSPD/ISPD
      COMMON/BOPT6/DELTAZ,SDELTA,RHO
      COMMON/BOPT7/ALPHA,BETA,OMEGA,EPSTIL,RH ,DELTIL,SIGMA,BIGL,AKAPPA
      COMMON/BOPT8/IV8,IV3
      COMMON/BSSVM1/THETAA,PHII,SHRIP1,SHRIP2,EPSS
      RETURN
      IF(L.GT.1)GOTO 42
      IF(IPT.EQ.0) GOTO 51
      WRITE(NFILE,911)IX
      WRITE(NFILE,919)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(NFILE,921)IST,NLNSR,NLOOP,LT,ISP,ISPD
                WRITE(NFILE,961)NBHHH
                WRITE(NFILE,951)RTM,EIG,RTMULT,ACTI
                WRITE(NFILE,952) ACTW,ZFUL,BETM
                WRITE(NFILE,941)ACC,FDFRAC,FDMIN,STPACC
51    IF(JPT.EQ.0) GOTO 50
      WRITE(MFILE,911)IX
      WRITE(MFILE,958)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(MFILE,960)IST,NLNSR,NLOOP,LT,ISP,ISPD
                WRITE(MFILE,961)NBHHH
                WRITE(MFILE,951)RTM,EIG,RTMULT,ACTI
                WRITE(MFILE,952) ACTW,ZFUL,BETM
                WRITE(MFILE,941)ACC,FDFRAC,FDMIN,STPACC
      GOTO 50
 42   IF(L.GT.2)GOTO 43
      IF(IPT.EQ.0) GOTO 52
      WRITE(NFILE,912)IX
      WRITE(NFILE,919)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(NFILE,922)IST,NLNSR,NLOOP,LT,IFP
                WRITE(NFILE,953)ACC,FDFRAC,FDMIN,STEP1
                WRITE(NFILE,954) STPACC,STPMIN,FPT
52    IF(JPT.EQ.0) GOTO 50
      WRITE(MFILE,912)IX
      WRITE(MFILE,958)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(MFILE,922)IST,NLNSR,NLOOP,LT,IFP
                WRITE(MFILE,953)ACC,FDFRAC,FDMIN,STEP1
                WRITE(MFILE,954) STPACC,STPMIN,FPT
      GOTO 50
 43   IF(L.GT.3)GOTO 44
      IF(IPT.EQ.0) GOTO 53
      WRITE(NFILE,913)
      WRITE(NFILE,919)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(NFILE,923)NLNSR,ACC,STEP1,STPACC
53    IF(JPT.EQ.0) GOTO 50
      WRITE(MFILE,913)
      WRITE(MFILE,958)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(MFILE,923)NLNSR,ACC,STEP1,STPACC
      GOTO 50
 44   IF(L.GT.4)GOTO 45
      IF(IPT.EQ.0) GOTO 54
      WRITE(NFILE,914)
      WRITE(NFILE,919)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(NFILE,924)NRST,KONVGE,ACC,STP1
54    IF(JPT.EQ.0) GOTO 50
      WRITE(MFILE,914)
      WRITE(MFILE,958)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(MFILE,924)NRST,KONVGE,ACC,STP1
      GOTO 50
45    IF(L.GT.5) GOTO 46
      IF(IPT.EQ.0) GOTO 55
      WRITE(NFILE,915)
      WRITE(NFILE,919)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(NFILE,925)ACC,STPSIZ,SHRINK
55    IF(JPT.EQ.0) GOTO 50
      WRITE(MFILE,915)
      WRITE(MFILE,958)NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE(MFILE,925)ACC,STPSIZ,SHRINK
      GOTO 50
46    IF(L.GT.6) GOTO 47
      IF(IPT.EQ.0) GOTO 56
      WRITE (NFILE,920)
      WRITE (NFILE,919) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE (NFILE,926) ACC,DELTAZ,SDELTA,RHO
56    IF(JPT.EQ.0) GOTO 50
      WRITE (MFILE,920)
      WRITE (MFILE,958) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
                WRITE (MFILE,926) ACC,DELTAZ,SDELTA,RHO
      GOTO 50
47    IF(L.GT.7) GOTO 48
      IF(IPT.EQ.0) GOTO 57
      WRITE (NFILE,933)
      WRITE (NFILE,959) NP,MX,IPT,ITERL,(ISTOP(I),I=1,3)
      WRITE (NFILE,934) (JSTOP(I),I=1,2)
57    IF(JPT.EQ.0) GOTO 50
      WRITE (MFILE,933)
      WRITE (MFILE,959) NP,MX,IPT,ITERL,(ISTOP(I),I=1,3)
      WRITE (MFILE,934) (JSTOP(I),I=1,2)
      GOTO 50
48    IF(L.GT.8) GOTO 49
      IF(IPT .EQ.0) GOTO 58
      WRITE (NFILE,935)
      WRITE (NFILE,919) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
      WRITE (NFILE,937) IV8,IV3
      WRITE (NFILE,955) ALPHA,BETA,OMEGA,EPSTIL,RH
      WRITE(NFILE,956) DELTIL,SIGMA,BIGL,AKAPPA
      WRITE (NFILE,938) ACC
58    IF(JPT.EQ.0) GOTO 50
      WRITE (MFILE,935)
      WRITE (MFILE,958) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
      WRITE (MFILE,937) IV8,IV3
      WRITE (MFILE,955) ALPHA,BETA,OMEGA,EPSTIL,RH
      WRITE(MFILE,956) DELTIL,SIGMA,BIGL,AKAPPA
      WRITE (MFILE,938) ACC
      GOTO 50
49    IF(IPT.EQ.0) GOTO 491
      WRITE (NFILE,939)
      WRITE (NFILE,919) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
      WRITE (NFILE,940) THETAA,PHII,SHRIP1,SHRIP2,EPSS
      WRITE (NFILE,938) ACC
491   IF(JPT.EQ.0) GOTO 50
      WRITE (MFILE,939)
      WRITE (MFILE,959) NP,MX,IPT,ITERL,NVAR1,(ISTOP(I),I=1,3)
      WRITE (MFILE,940) THETAA,PHII,SHRIP1,SHRIP2,EPSS
      WRITE (MFILE,938) ACC
50    CONTINUE
70    IF(IPT .EQ.0) GOTO 59
      IF(ITOB.EQ.1) WRITE (NFILE, 928)
      IF(IPROB.EQ.1) WRITE (NFILE,927)
      WRITE(NFILE,918)F
      WRITE(NFILE,950)(A0(I),I=1,NP)
59    IF(JPT.EQ.0) GOTO 60
      IF(ITOB.EQ.1) WRITE (MFILE,928)
      IF(IPROB.EQ.1) WRITE (MFILE,927)
      WRITE(MFILE,918)F
      WRITE(MFILE,957)(A0(I),I=1,NP)
60    RETURN
 911  FORMAT('1',30X,13HGRADX VERSION,I2,7H BEGINS/)
 912  FORMAT('1',30X,13H DFP  VERSION,I2,7H BEGINS/)
 913  FORMAT('1',30X,13HPOWELL BEGINS/)
 914  FORMAT('1',30X,13HNMSIMP BEGINS/)
 915  FORMAT('1',30X,13HPATERN BEGINS/)
 917  FORMAT(8(1PD15.6))
 918  FORMAT(/,' INITIAL F VALUE  =',1PD15.6/' INITIAL X VECTOR =')
 919  FORMAT(' CALLING PARAMETERS',///'     NP=',I5,'     MX=',I5,8H
     1IPT=,I5/'  ITERL=',I5,'   NVAR1=',I5/'  ISTOP=',3(3X,I2))
920   FORMAT('1',30X,'RNSRCH BEGINS',////)
 921  FORMAT('    IST=',I5/'  NLNSR=',I5/'  NLOOP=',I5/'     LT=',
     1I5/'    ISP=',I5/'   ISPD=',I5)
 922  FORMAT('    IST=',I5/'  NLNSR=',I5/'  NLOOP=',I5/'     LT=',
     1I5/'    IFP=',I5)
 923  FORMAT('  NLNSR=', I5//5X,'ACC',9X,'STEP1',6X,'STPACC'/3(1X,
     11PD11.3))
 924  FORMAT('   NRST=', I5/' KONVGE=',I5//5X,'ACC',8X,'STP1'/2(1X,
     11PD11.3))
 925  FORMAT(/,6X,'ACC',7X,'STPSIZ',6X,'SHRINK'/3(1X,1PD11.3))
926   FORMAT(/,6X,'ACC',7X,'DELTAZ',6X,'SDELTA',6X,'RHO'/4(1X,1PD11.3))
927   FORMAT(//,' *******  THIS IS A SIMPLE PROBIT PROBLEM  *******')
928   FORMAT(//,' *******  THIS IS A TOBIT PROBLEM  *******')
929   FORMAT(' PROBIT AND TOBIT MAY NOT BOTH BE SELECTED')
 931  FORMAT(/,5X,'RTM',9X,'EIG',7X,'RTMULT',8X,'ACTI',8X,'ACTW',8X,
     1'ZFUL',7X,'BETM'/7(1X,1PD11.3))
 932  FORMAT(/,5X,'ACC',7X,'HFDFRAC',6X,'FDMIN',8X,'STEP1',6X,'STPACC',
     16X,'STPMIN',7X,'FOPT'/(1X,1PD11.3))
933   FORMAT(1H1,30X,'SEQOPT BEGINS',/)
934   FORMAT('  JSTOP=',2(3X,I2))
935   FORMAT(1H1,30X,'MUKAI BEGINS',/)
936   FORMAT(/,6X,'ALPHA',5X,'BETA',8X,'OMEGA ',6X,'EPSTIL',8X,'RH  ',
     1  6X,'DELTIL',7X,'SIGMA',8X,'BIGL',6X,'AKAPPA',/9(1X,1PD11.3))
937   FORMAT(/,'   IV8=',I5/'    IV3=',I5)
938   FORMAT(/,5X,'ACC'/1X,1PD11.3)
939   FORMAT('1',40X,'SSVM BEGINS',////)
940   FORMAT(/,6X,'THETA',5X,' PHI',8X,'SHRINK',6X,'EXPAND',8X,'EPSILON'
     1 /5(1X,1PD11.3))
 941  FORMAT(/,6X,'ACC',7X,'FDFRAC',6X,'FDMIN',7X,'STPACC'/4(1X,
     11PD11.3))
950   FORMAT(1X,5D14.6)
951   FORMAT(/,6X,'RTM',9X,'EIG',7X,'RTMULT',8X,'ACTI'/4(1X,1PD11.3))
952   FORMAT(8X,'ACTW',8X,'ZFUL',8X,'BETM'/3(1X,1PD11.3))
953   FORMAT(6X,'ACC',7X,'FDFRAC',6X,'FDMIN',8X,'STEP1'/4(1X,1PD11.3))
954   FORMAT(6X,'STPACC',6X,'STPMIN',7X,'FOPT'/3(1X,1PD11.3))
955   FORMAT(6X,'ALPHA',5X,'BETA',8X,'OMEGA',6X,'EPSTIL',8X,'RH  ',
     1/5(1X,1PD11.3))
956   FORMAT(6X,'DELTIL',7X,'SIGMA',8X,'BIGL',6X,'AKAPPA',/4(1X,1PD11.3)
     1)
957   FORMAT(1X,5D14.6)
958   FORMAT(' CALLING PARAMETERS'//'     NP=',I5,'     MX=',I5,'    IPT
     1=',I5/'  ITERL=',I5,'  NVAR1=',I5,'  ISTOP=',3(3X,I2))
 959  FORMAT(' CALLING PARAMETERS'//'     NP=',I5,'     MX=',I5,'    IPT
     1=',I5/'  ITERL=',I5,'  ISTOP=',3(3X,I2))
 960  FORMAT(/,'   IST=', I5,'  NLNSR=',I5,'  NLOOP=',I5/'     LT=',
     1I5,'    ISP=',I5,'   ISPD=',I5)
 961  FORMAT('  BHHH=',I5)
      END
      SUBROUTINE OPTOU1(K,ITERC,SOURCE,IVAL,FU0,X)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(K)
      character*4 SOURCE
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      RETURN
      IF(IPT .EQ.0) GOTO 9
      IF(ITERC.EQ.0)WRITE(NFILE,902)
      IF (K .LE. 3) WRITE(NFILE,907) ITERC,SOURCE,IVAL,FU0,(X(I),I=1,K)
      IF (K.GT. 3) WRITE(NFILE,907) ITERC,SOURCE,IVAL,FU0,(X(I),I=1,3)
      IF (K.GT. 3) WRITE(NFILE,908) (X(I),I=4,K)
 902  FORMAT(28H1ITERA TYPE  NO.    FUNCTION/6H  TION,6X,14HEVAL     VAL
     1UE/)
 904  FORMAT(1(35X,6(1PD14.6)))
9     IF (JPT.EQ.0) RETURN
      IF (ITERC .EQ. 0) WRITE(MFILE,902)
      IF (K .LE. 3) WRITE(MFILE,907) ITERC,SOURCE,IVAL,FU0,(X(I),I=1,K)
      IF (K.GT. 3) WRITE(MFILE,907) ITERC,SOURCE,IVAL,FU0,(X(I),I=1,3)
      IF (K.GT. 3) WRITE(MFILE,908) (X(I),I=4,K)
907   FORMAT(1X,I4,2X,A4,1X,I4,1X,1PD13.6,2X,3H X=,3(1PD14.6))
908   FORMAT(1(35X,3(1PD14.6)))
      RETURN
      END
      SUBROUTINE LABEL (a,NP)
CVMS  modified to xlabel: not as in handbook uses char vbles
      character*8 a(NP)
      character*4 d(2)
      character*8 c
      equivalence (c,d(1))
      data c/'  X-    '/
      DO 100 I=1,NP
c   harry
c     d(2)=char(ichar(i))
  100 a(i)=c
      return
      end
      SUBROUTINE PERM1 (A,NP,NPE,FU0,*,FUNC)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NP)
      COMMON/BPRM/IPRM(1)
      COMMON/BPRM2/XPRM(1)
      EXTERNAL FUNC
C
      DO 10 I = 1, NPE
10    XPRM(IPRM(I)) = A(I)
      CALL FUNC (XPRM,NP,FU0,*20)
      RETURN
C
20    RETURN 1
      END
      SUBROUTINE PRMCHK (NP, X, A, IFLAG, *)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/BPRM/IPRM(1)
      COMMON/BPRM2/XPRM(1)
      DIMENSION X(NP),A(NP)
C
C       PRMCHK ACCEPTS A PERMUTATION IPRM.  IT THEN CHECKS THAT IT
C       IS A VALID PERMUTATION.  IF IT IS A CORRECT PERMUTATION, AND
C       IF IFLAG = 1, ARRAYS X AND A ARE PERMUTED.  X IS NORMALLY THE
C       VARIABLE ARRAY AND A IS THE LABEL ARRAY.  REGARDLESS OF THE
C       VALUE OF IFLAG, THE UNPERMUTED X ARRAY IS THEN STORED IN XPRM.
C
C       PERMUTATIONS ARE CHECKED IN PLACE, BY THE FOLLOWING METHOD:
C       WE ARE USING ONE WAY TO EXPRESS A PERMUTATION.  FOR INSTANCE,
C       IPRM = 4,6,2,1,5,3 MEANS X(1) WILL EVENTUALLY HAVE REAL VARIABLE
C       4, X(2) WILL EVENTUALLY CONTAIN REAL VARIABLE 6, X(3) WILL
C       EVENTUALLY CONTAIN REAL VARIABLE 2, ETC. ANOTHER WAY TO EXPRESS
C       THIS SAME PERMUTATION IS (14)(263)(5).  THERE ARE THREE LOOPS
C       HERE: THE FIRST MEANS THAT XNEW(1) = X(4), AND XNEW(4) = X(1).
C       THE SECOND MEANS THAT XNEW(2) = X(6), XNEW(6) = X(3), AND
C       XNEW(3) = X(2).  THE THIRD MEANS THAT XNEW(5) = X(5).  THE
C       ALGORITHM WHICH FOLLOWS DETECTS THESE LOOPS, AND USES THEM TO
C       CHECK THE PERMUTATION IN PLACE (I.E. WITHOUT USING AUXILLARY
C       STORAGE).
C
C       FIRST, CHECK THAT ALL VALUES OF IPRM ARE IN THE RANGE 1 TO NP.
C       THEN "MARK" EACH VALUE BY MAKING IT NEGATIVE.
C
      DO 1 I=1,NP
      J = IPRM(I)
      IF (J.LT.1.OR.J.GT.NP) GO TO 999
1     IPRM(I) = -J
C
C       NOW, WE SEARCH FOR PERMUTATION LOOPS.  WE START WITH ELEMENT
C       K=1. IF IPRM(K) IS POSITIVE, WE KNOW THAT K WAS PART OF AN
C       EARLIER PERMUTATION LOOP, SO WE JUST SKIP THAT K.  ONCE WE FIND
C       A K FOR WHICH IPRM(K) IS NEGATIVE, WE KNOW WE HAVE FOUND A NEW
C       PERMUTATION LOOP.
C       WE SET L TO K, AND UNMARK IPRM(L) BY MAKING IT POSITIVE.  WE
C       LET J = IPRM(L).  WE SET L TO J, AND CONTINUE LOOPING,
C       UNMARKING ELEMENTS OF THE LOOP.  EVENTUALLY WE COME TO AN
C       ELEMENT WHICH IS ALREADY UNMARKED.  THIS SHOULD BE K, THE
C       FIRST ELEMENT OF THE LOOP.  IF IT IS NOT, WE DO NOT HAVE A
C       VALID PERMUTATION.  IF IT IS, WE LOOK FOR ANOTHER UNMARKED
C       ELEMENT, AND CONTINUE THE PROCESS.
C       ONCE K EXCEEDS NP, ALL ELEMENTS ARE UNMARKED AND THEREFORE PART
C       OF A VALID LOOP.  THEREFORE WE MUST HAVE A VALID PERMUTATION.
C
      DO 2 K=1,NP
      IF (IPRM(K).GT.0) GO TO 2
      L = K
4     J = -IPRM(L)
      IPRM(L) = J
      IF (IPRM(J).GT.0) GO TO 3
      L = J
      GO TO 4
C
3     IF (J.NE.K) GO TO 999
2     CONTINUE
C
      IF (IFLAG.EQ.0) GO TO 20
C
C       IF X AND A ARE TO BE PERMUTED, THE SAME PROCESS IS FOLLOWED.
C       XK AND AK ARE SAVED, THE X AND A OF THE FIRST ELEMENT IN THE
C       LOOP.  EACH ELEMENT IS THEN GIVEN THE VALUES OF THE NEXT
C       ELEMENT IN THE LOOP. THE LAST ELEMENT IN THE LOOP IS GIVEN THE
C       VALUES XK AND AK, WHICH WERE SAVED FROM THE FIRST ELEMENT.
C
      DO 10 I=1,NP
10    IPRM(I) = -IPRM(I)
C
      DO 11 K=1,NP
      IF (IPRM(K).GT.0) GO TO 11
      XK = X(K)
      AK = A(K)
      L = K
13    J = -IPRM(L)
      IPRM(L) = J
      IF (IPRM(J).GT.0) GO TO 12
      X(L) = X(J)
      A(L) = A(J)
      L = J
      GO TO 13
C
12    X(L) = XK
      A(L) = AK
11    CONTINUE
C
C       COPY X (UNPERMUTED) INTO XPRM.
C
20    DO 21 I=1,NP
21    XPRM(IPRM(I)) = X(I)
      RETURN
C
C       IF ERROR, UNMARK ANY ELEMENTS OF XPRM WHICH REMAIN MARKED.
C
999   DO 1000 I = 1,NP
1000  IF (IPRM(I).LT.0) IPRM(I) = -IPRM(I)
      RETURN 1
      END
      SUBROUTINE OPTOUT(M)
C   OUTPUT ROUTINE FOR OPT PACKAGE
C     N = 0  FOR OUTPUT OF ALL ARRAYS
C         1  FOR OUTPUT OF H MATRIX OR INVERSE 2ND DER (IF AVAIL.)
C         2  FOR OUTPUT OF 2ND DERIVATIVE MATRIX (IF AVAIL)
C         3  FOR OUTPUT OF GRADIENT (IF AVAIL)
C         4  FOR OUTPUT OF SIMPLEX (IF AVAIL)
C         5  FOR OUTPUT OF SEARCH DIRECTION (IF AVAIL)
C         6  FOR OUTPUT OF DIAGONAL OF 2ND DERIVATIVE (IF AVAIL).
C         7  FOR OUTPUT OF MODIFIED H MATRIX (IF AVAIL).
      IMPLICIT REAL*8 (A-H,O-Z)
      character*4 C(7),SNAME
      COMMON/BSTACK/A(150000)
      COMMON/BOPT1/NPARS,JH,JFP,JFP1,JSP,JSP2,JA1,JS,JBHHH
      COMMON/BOPT3/JSMP,JF,JSPD
      COMMON/BOPT9/JX1,JD0,JD1,JTEMV,JG0,JG1,JV,JP,JQ,JSS,JXT
      COMMON/BNOBS/NOBSS
      COMMON/BOUT1/IMODIF
      DATA C/1HH,4H2NDD,4HGRAD,4HSMPX,4HSRCH,4HD2ND,1HH/
      DATA SNAME/3HOUT/
      IMODIF=0
101   N=M
      IF(N.EQ.0)N=1
 100  IF(N.LE.0 .OR. N.GE.8)RETURN
      N1=1
      N2=NPARS
      GO TO(1,2,3,4,5,6,7),N
7     IF (NOBSS.EQ.0) GO TO 120
      IMODIF=1
 1    N1=NPARS
      J=JH
      IF(JH.LE.0)J=JSP1
      IF(J.LE.0) J=JD0
      GOTO 110
 2    J=JSP
      N1=NPARS
      GOTO 110
 3    J=JFP
      IF(JFP.LE.0) J=JG0
      GOTO 110
 4    J=JSMP
      N1=NPARS
      GOTO 110
 5    J=JS
      IF(JS.LE.0) J=JSS
      GOTO 110
 6    J=JSPD
 110  IF(J.LT.1)GOTO 120
      CALL DBPM(SNAME,C(N),A(J),N1,N1,N2)
 120  IF(M.NE.0)RETURN
      N=N+1
      GOTO 100
      END
      SUBROUTINE DBPM(SNAME,ANAME,A,N,NDIM,M)
      IMPLICIT REAL*8 (A-H,O-Z)
C      DBPM   TRACE PRINT OF MATRIX
C      PRINTS THE MATRIX A IN TABLE OF N ROWS AND M COLUMNS
C      NDIM IS THE NO. OF ROWS IN DIMENSION OF A
C      SNAME AND ANAME ARE NAMES OF CALLING ROUTINE AND ARRAY
      DIMENSION A(NDIM,M),OUTST(10)
      COMMON/BOUT1/IMODIF
      COMMON/BPRINT/IPT,NFILE,NDIG,NPUNCH,JPT,MFILE
      COMMON/BVAL/VAL
      COMMON/BNOBS/NOBSS
      IF (IPT.EQ.0) GOTO 2000
      IF (IMODIF.EQ.1) GO TO 5
      IF(IPT .NE. 0) WRITE(NFILE,1)ANAME,SNAME,N,M
 1    FORMAT(/7H ARRAY ,            A4,14H FROM ROUTINE ,A4/5X,I4,4H BY
     1,I4,6H ARRAY)
      GO TO 3
5     IF (IPT .NE. 0) WRITE (NFILE,4)
4     FORMAT ('-'/' ASYMPTOTIC COVARIANCE MATRIX')
      FACT=2.0D0*VAL/DFLOAT(NOBSS)
3     J1=1
C      MAX NO. OF COLUMNS
      JMAX=MAX0(9-(NDIG/3)*2,5)
      JJ=MIN0(JMAX,M)
 100  DO 20 I=1,N
      IF (IMODIF.EQ.1) GO TO 22
      DO 21 J=J1,JJ
21    OUTST(J-J1+1)=A(I,J)
      GO TO 23
22    DO 24 J=J1,JJ
24    OUTST(J-J1+1)=A(I,J)*FACT
23    CONTINUE
      IF(JMAX.GE.9)WRITE(NFILE,101)(OUTST(J-J1+1),J=J1,JJ)
      IF(JMAX.GE.7.AND.JMAX.LT.9)WRITE(NFILE,80)(OUTST(J-J1+1),J=J1,JJ)
      IF(JMAX.LT.7)WRITE(NFILE,60)(OUTST(J-J1+1),J=J1,JJ)
20      CONTINUE
      IF(JJ.GE.M) GOTO 2000
      J1=JJ+1
      JJ=MIN0(JJ+JMAX,M)
      IF(N.GT.1.AND.IPT.NE.0)WRITE(NFILE,2)
 2    FORMAT(//)
      GOTO 100
2000     IF (JPT.EQ.0) RETURN
         IF (IMODIF.EQ.1) GOTO 50
         WRITE(MFILE,1) ANAME,SNAME,N,M
         GOTO 30
50       WRITE(MFILE,4)
30       J1=1
C      MAX NUMBER OF COLUMNS
         JMAX=MAX0(9-(NDIG/3)*2,5)
         JJ=MIN0(JMAX,M)
1000     DO 200 I=1,N
         IF (IMODIF.EQ.1) GOTO 220
         DO 210 J=J1,JJ
210      OUTST(J-J1+1)=A(I,J)
         GOTO  230
220      DO 240 J=J1,JJ
240      OUTST(J-J1+1)=A(I,J)*FACT
230      CONTINUE
      IF(JMAX.GE.9)WRITE(MFILE,101)(OUTST(J-J1+1),J=J1,JJ)
      IF(JMAX.GE.7.AND.JMAX.LT.9)WRITE(MFILE,80)(OUTST(J-J1+1),J=J1,JJ)
      IF(JMAX.LT.7)WRITE(MFILE,60)(OUTST(J-J1+1),J=J1,JJ)
60    FORMAT(1X,5 (1PD15.8))
80    FORMAT(1X,7 (1PD11.4))
101   FORMAT(1X,9(1PD 8.1))
200      CONTINUE
      IF(JJ.GE.M) RETURN
      J1=JJ+1
      JJ=MIN0(JJ+JMAX,M)
      IF(N.GT.1) WRITE(MFILE,2)
      GOTO 1000
        END
